home *** CD-ROM | disk | FTP | other *** search
/ BBS in a Box 9 / AMUG BBS in a Box Volume IX (August 1993) (MacWizards).iso / Files / Prog / S / Small Talk.cpt / Small Talk / Interfac.st next >
Encoding:
Text File  |  1986-01-13  |  8.0 KB  |  242 lines  |  [TEXT/ttxt]
  1. StringHolder subclass: #ProtocolBrowser
  2.     instanceVariableNames: 'list classDictionary selectedClass selectedSelector listIndex view isInstance originalClass listView '
  3.     classVariableNames: ''
  4.     poolDictionaries: ''
  5.     category: 'Interface-Protocol'!
  6. ProtocolBrowser comment:
  7. 'This class represents a browser in which you can examine the message interface of a particular class.
  8.  
  9.     ProtocolBrowser openForClass: className'!
  10.  
  11. !ProtocolBrowser methodsFor: 'list access'!
  12. listIndex
  13.     "Answer the current list index"
  14.  
  15.     ^listIndex!
  16. selectedClass
  17.     "Answer the currently selected class from the menu"
  18.  
  19.     ^selectedClass!
  20. selectedSelector
  21.     "Answer the currently selected selector from the menu"
  22.  
  23.     ^selectedSelector!
  24. selectorList
  25.     "Answer the list of strings that show in the list menu"
  26.  
  27.     ^list!
  28. toggleListIndex: anInteger
  29.     "Change selected item to anInteger. If already selected then deselect"
  30.  
  31.     | aString |
  32.     anInteger = listIndex
  33.         ifTrue: [listIndex_0. selectedSelector _ nil]
  34.       ifFalse: [listIndex_anInteger. aString _ list at: anInteger.
  35.                 selectedSelector _ (aString copyUpTo: Character tab) asSymbol.
  36.                 selectedClass _ classDictionary at: selectedSelector].
  37.     self changed: #listIndex! !
  38.  
  39. !ProtocolBrowser methodsFor: 'text access'!
  40. contents
  41.     "Answer the Symbol identifying the text of the menu"
  42.  
  43.     selectedSelector==nil
  44.            ifTrue: [^'' asText]
  45.           ifFalse: [^(selectedClass sourceCodeAt: selectedSelector) asText
  46.                     makeSelectorBoldIn: selectedClass]!
  47. contents: aText notifying: aController 
  48.     "Answer the message selector for changing the displayed text."
  49.  
  50.     | newSelector |
  51.     newSelector _ selectedClass
  52.                 compile: aText
  53.                 classified: (selectedClass organization categoryOfElement: selectedSelector)
  54.                 notifying: aController.
  55.     newSelector == nil ifTrue: [^false].
  56.     newSelector == selectedSelector ifFalse: [self newSelectorList: newSelector].
  57.     ^true! !
  58.  
  59. !ProtocolBrowser methodsFor: 'view changing'!
  60. displayMode: aSymbol
  61.     "alter the display to be full or partial and class or instance oriented as directed by aSymbol"
  62.  
  63.     | exclusions |
  64.     isInstance == aSymbol ifTrue: [^self].
  65.     view erase.
  66.     aSymbol == #partialInstance | (aSymbol == #partialClass) ifTrue:
  67.         [exclusions_Array new: 5;
  68.         at: 1 put: Object;
  69.         at: 2 put: Behavior;
  70.         at: 3 put: ClassDescription;
  71.         at: 4 put: Class;
  72.         at: 5 put: (Object class)].
  73.     Cursor execute showWhile: 
  74.         [aSymbol == #fullInstance
  75.             ifTrue: [self on: originalClass].
  76.          aSymbol == #fullClass
  77.             ifTrue: [self on: (originalClass class)].
  78.          aSymbol == #partialInstance
  79.             ifTrue: [self on: originalClass without: exclusions].
  80.          aSymbol == #partialClass
  81.             ifTrue: [self on: (originalClass class) without: exclusions]].
  82.     listView list: self selectorList.
  83.     self toggleListIndex: listIndex.
  84.     view display.
  85.     view emphasizeLabel.
  86.     isInstance _ aSymbol
  87. ! !
  88.  
  89. !ProtocolBrowser methodsFor: 'private'!
  90. newSelectorList: aSelector
  91.     "update the selector list with the newly compiled new selector"
  92.  
  93.     | oldClass newString oldString newIndex |
  94.     newIndex _ 0.
  95.     newString _ aSelector printString , '    (' , selectedClass name , ') '.
  96.     oldClass _ classDictionary 
  97.         at: aSelector
  98.         ifAbsent: [classDictionary add: (Association key: aSelector value: selectedClass).
  99.                    list do: [ :oldString |  newIndex _ newIndex + 1.
  100.                             newString < oldString ifTrue: 
  101.                                 [list add: newString before: oldString.
  102.                                  self readjustList: newIndex. ^self]].
  103.                   list addLast:  newString. self readjustList: newIndex + 1. ^self].
  104.     oldClass == selectedClass ifFalse:  "looks like they recompiled to a different class"
  105.             [classDictionary at: aSelector put: selectedClass.
  106.             list do: [ :oldString | newIndex _ newIndex + 1.
  107.                     aSelector == (oldString copyUpTo: Character tab) asSymbol                         ifTrue: 
  108.                             [list at: newIndex put: newString.
  109.                                  self readjustList: newIndex. ^self]
  110.                     ]
  111.             ]!
  112. on: aClass 
  113.     "Create the protocol browser for the class, aClass."
  114.  
  115.     | defClass label|
  116.     list _ OrderedCollection new.
  117.     classDictionary _ Dictionary new.
  118.     aClass allSelectors asSortedCollection do: 
  119.         [:selector | 
  120.         defClass _ aClass whichClassIncludesSelector: selector.
  121.         list add: selector printString , '    (' , defClass name , ') '.
  122.         classDictionary add: (Association key: selector value: defClass)].
  123.     label _ 'Entire protocol of: ' , aClass name.
  124.     view label: label
  125. !
  126. on: aClass without: aCollection
  127.     "Create the protocol browser for the class, aClass, leaving out any classes in aCollection."
  128.  
  129.     | defClass label|
  130.     list _ OrderedCollection new.
  131.     classDictionary _ Dictionary new.
  132.     aClass allSelectors asSortedCollection do: 
  133.         [:selector | 
  134.         defClass _ aClass whichClassIncludesSelector: selector.
  135.          (defClass == aClass or: [(aCollection includes: defClass) not])
  136.         ifTrue:
  137.             [list add: selector printString , '    (' , defClass name , ') '.
  138.              classDictionary add: (Association key: selector value: defClass)]].
  139.     label _ 'Partial protocol of: ' , aClass name.
  140.     view label: label
  141. !
  142. originalClass: aClass view: aView listView: anotherView
  143.     "remember where we started"
  144.  
  145.     isInstance _ #partialInstance.
  146.     originalClass_aClass.
  147.     listView _ anotherView.
  148.     view_aView!
  149. readjustList: newIndex
  150.     "after compiling a method with a new selector, get the list back in shape on the menu"
  151.  
  152.     listIndex _ 0.
  153.     self toggleListIndex: newIndex.
  154.     listView list: list.
  155.     listView moveSelectionBox: newIndex. 
  156.     self inspect.
  157.     ^self
  158. ! !
  159. "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!
  160.  
  161. ProtocolBrowser class
  162.     instanceVariableNames: ''!
  163.  
  164. !ProtocolBrowser class methodsFor: 'instance creation'!
  165. openForClass: aClass 
  166.     "Create and schedule a browser for the entire protocol of the class. "
  167.  
  168.     | topView aPBrowser myList myCode |
  169.     aPBrowser _ super new.
  170.     topView _ StandardSystemView new.
  171.     myList _ ListView new.
  172.     aPBrowser originalClass: aClass view: topView listView: myList.
  173.     Cursor execute showWhile: [aClass == Object 
  174.                 ifTrue: [aPBrowser on: aClass]
  175.                 ifFalse: [aPBrowser on: aClass without: (Array with: Object)]].
  176.     topView model: aPBrowser.
  177.     topView minimumSize: 200 @ 200.
  178.     myList model: aPBrowser controller: ProtocolListController new.
  179.     myList borderWidthLeft: 2 right: 2 top: 2 bottom: 2.
  180.     myList list: aPBrowser selectorList.
  181.     myCode _ StringHolderView new.
  182.     myCode model: aPBrowser controller: BrowserCodeController new.
  183.     myCode borderWidthLeft: 2 right: 2 top: 0 bottom: 2.
  184.     topView addSubView: myList.
  185.     topView addSubView: myCode.
  186.     myList window: myList window viewport: (myCode viewport topLeft  corner:  myCode viewport topRight + (0@100)).
  187.     myCode window: myCode window viewport: (myCode viewport topLeft +(0@100) corner:  myCode viewport bottomRight).
  188.     myList controller yellowButtonMenu: 
  189.         (PopUpMenu labels:
  190. 'senders
  191. implementors
  192. messages
  193. partial instance
  194. partial class
  195. full instance
  196. full class'
  197.         lines: #( 3 5))
  198.  
  199.          yellowButtonMessages: #(browseSenders browseImplementors browseMessages partialInstance partialClass fullInstance fullClass ).
  200.     topView controller open! !
  201.  
  202. ListController subclass: #ProtocolListController
  203.     instanceVariableNames: ''
  204.     classVariableNames: ''
  205.     poolDictionaries: ''
  206.     category: 'Interface-Protocol'!
  207.  
  208. !ProtocolListController methodsFor: 'list functions'!
  209. browseImplementors
  210.     "Create a message-set browser for the implementors of the selected 
  211.     message. "
  212.  
  213.     Smalltalk browseAllImplementorsOf: self model selectedSelector!
  214. browseMessages
  215.     "Create a menu of the messages in the selected method and then, if the user selects a menu item, create  a message-set browser for the methods that implement it. "
  216.  
  217.     Smalltalk showMenuThenBrowse:
  218.         (self model selectedClass compiledMethodAt: self model selectedSelector)
  219.             messages asSortedCollection!
  220. browseSenders
  221.     "Create a message-set browser for the methods that include the selected 
  222.     message. "
  223.  
  224.     Smalltalk browseAllCallsOn: self model selectedSelector! !
  225.  
  226. !ProtocolListController methodsFor: 'class changing'!
  227. fullClass
  228.     "change the view to the class variety"
  229.  
  230.     self model displayMode: #fullClass!
  231. fullInstance
  232.     "change the view to the instance variety"
  233.  
  234.     self model displayMode: #fullInstance!
  235. partialClass
  236.     "change the view to the class variety"
  237.  
  238.     self model displayMode: #partialClass!
  239. partialInstance
  240.     "change the view to the instance variety"
  241.  
  242.     self model displayMode: #partialInstance! !